home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Collections: New Zealand Amiga Users Group
/
New Zealand Amiga Users Group Newsdisk v03 (1987-02)(NZAmigaUG).zip
/
New Zealand Amiga Users Group Newsdisk v03 (1987-02)(NZAmigaUG).adf
/
BASIC
/
ScapeGen16a
< prev
next >
Wrap
Text File
|
1993-12-02
|
3KB
|
80 lines
REM FRACTAL LANDSCAPES with SOLID SURFACE by G Thornton
CLEAR ,50000&
SCREEN 1,640,200,4,2
WINDOW 2,"Fractal landscapes Mk II [hit <RETURN> to exit]",,0,1
RANDOMIZE TIMER: COLOR 2,10
DIM d%(128,128)
FOR i=0 TO 15:READ r,g,b:PALETTE i,r/15,g/15,b/15:NEXT
DATA 11,6,6,0,7,15,13,12,8,6,12,6,5,10,0,0,8,5,0,7,0,3,5,0,5,5,4
DATA 5,4,0,6,5,0,7,6,5,8,7,6,8,8,8,11,11,11,15,15,15
water=-200:sea=1
30 INPUT "Number of levels <1-7> ";le: IF le < 1 OR le > 7 THEN 30
INPUT "Variable smoothness (Y/N) ";smoo$
IF LEFT$(UCASE$(smoo$),1)="Y" THEN hill=1 ELSE hill=0
40 IF hill=0 THEN INPUT "Enter smoothness (1.5-2.5) :",Sm
mx=2^le
50 pi=3.14159:my=mx/2
60 FOR n=1 TO le:IF hill=0 THEN L=15000/Sm^n
70 PRINT : PRINT "Working on level ";n
80 ib=mx/2^n:sk=ib*2
90 GOSUB 150: ' *** Assign heights along X in array ***
100 GOSUB 220: ' *** Assign heights along Y in array ***
110 GOSUB 290: ' *** Assign heights along diag. in array ***
120 NEXT n
IF sea=0 THEN 130
FOR i=0 TO mx :FOR j=0 TO mx
IF d%(i,j)<water THEN d%(i,j)=water ELSE IF d%(i,j)>maxz THEN maxz=d%(i,j)
NEXT j,i
130 GOTO 640: ' *** Draw ***
' *** Heights along x ***
150 FOR ye = 0 TO mx STEP sk
IF hill=1 THEN L=15000/(1.3+le/20+(ye/mx*(.8-le/20)))^n
FOR xe = ib TO mx STEP sk
d%(xe,ye)=(d%(xe-ib,ye)+d%(xe+ib,ye))/2 + RND*L/2-L/4
NEXT xe
NEXT ye: RETURN
' *** Heights along Y ***
220 FOR ye = ib TO mx STEP sk
IF hill=1 THEN L=15000/(1.3+le/20+(ye/mx*(.8-le/20)))^n
FOR xe = 0 TO mx STEP sk
d%(xe,ye)=(d%(xe,ye-ib)+d%(xe,ye+ib))/2+ RND*L/2-L/4
NEXT xe
NEXT ye: RETURN
' *** Heights along diag. ***
290 sq2=SQR(2)
FOR ye = ib TO mx STEP sk
IF hill=1 THEN L=15000/(1.3+le/20+(ye/mx*(.8-le/20)))^n
FOR xe = ib TO mx STEP sk
d%(xe,ye)=(d%(xe-ib,ye+ib)+d%(xe+ib,ye-ib))/2+ RND*L/sq2-L/2/sq2
NEXT xe
NEXT ye: RETURN
630 ' **** Display here ****
640 GOSUB 1100: ' *** Set up plotting device or screen ***
xa=55/mx/mx: ys = 120/mx: yc=50: zs=yc/maxz*.85:' *** scaling factors ***
FOR ay = 0 TO mx-1 :ays=ay*ys+yc:xs=(550+55*ay/mx)/mx
FOR ax = 0 TO mx-1 :axs=ax*xs:ax1=axs+xs
z1=d%(ax,ay):z2=d%(ax,ay+1):z3=d%(ax+1,ay)
GOSUB Tricolour :ay2=ays+ys-z2*zs:ay3=ays-z3*zs
AREA(axs,ays-z1*zs):AREA(axs+xa*ax,ay2):AREA(ax1,ay3):AREAFILL
z1=d%(ax+1,ay+1):GOSUB Tricolour
AREA(ax1+xa*(ax+1),ays+ys-z1*zs):AREA(axs,ay2):AREA(ax1,ay3):AREAFILL
NEXT ax,ay
750 GOTO 1130: ' *** done plotting, goto end loop ***
Tricolour: height=(z1+z2+z3)/3 - water
IF height<10 THEN COLOR 1:RETURN
hi=INT(height/maxz*14+1+RND*.5):IF hi>14 THEN hi=14
COLOR 1+hi
RETURN
1100 ' * * * setup plotting device or screen * * *
1110 CLS: LINE (0,0)-(620,190),0,bf: RETURN
1120 ' *** End loop ***
1130 '
1140 INPUT "",E$
SCREEN CLOSE 1
END